;;;; Copyright 2009 Peter von Etter

;;;; This file is part of Autoproject

;;;; Autoproject is free software: you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation, either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; Autoproject is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with Autoproject.  If not, see
;;;; <http://www.gnu.org/licenses/>.

;;;; Simple CRUD

(in-package :autoproject.crud)

(defvar *return-instance* t
  "If non-nil, return a fresh instance on create and update.  This
  will do nothing for create if the db adapter doesn't implement get-last-id")

;;;; Checks

(defmethod check-table (crud table)
  (>> (get-fields crud table)
      (prog1 it (assert it))))

(defmethod check-table-columns (crud table values)
  (>> (check-table crud table)
      (loop :for (a b) :on values :by #'cddr
            :do (assert (gethash a it)))
      t))


;;;; CRUD operations

(defmethod call-with-db (crud fn)
  (call-with-db (get-db-adapter crud) fn))

(defmethod call-with-transaction (crud fn)        
  (call-with-transaction (get-db-adapter crud) fn))

(defgeneric crud-execute-raw (crud sql-statement)
  (:documentation "
Executes SQL-STATEMENT in the database of CRUD."))
  
(defmethod crud-execute-raw (crud statement)
  (with-crud (crud)
    (db-query (get-db-adapter crud) statement)))


(defgeneric crud-select-raw (crud select-or-string)
  (:documentation "
Returns the results of the query SELECT-OR-STRING directly.  This is
useful for queries that do not return results that could be mapped to
instances.  The format of the result is dependent on the db adapter of
CRUD."))
  
(defmethod crud-select-raw (crud select)
  (let (a b)
    (with-crud (crud)
      (multiple-value-bind (a* b*)
          (db-query (get-db-adapter crud) (apply-select select))
        (setf a a*)
        (setf b b*)))
    (values a b))) 

(defmethod crud-select-raw (crud (query string))
  (let (a b)
    (with-crud (crud)
      (multiple-value-bind (a* b*) 
          (db-query (get-db-adapter crud) query)
        (setf a a*)
        (setf b b*)))
    (values a b)))

(defun detect-multiple-tables (select)
  (or (listp (get-select-property select :table))
      (get-select-property select :join)))

(defmethod crud-select-multiple (crud select)
  (>> (extract-multiple-tables select)
      (with-crud (crud)
        (rows-multiple-instances 
         crud it (db-query (get-db-adapter crud) (apply-select select))))))


(defgeneric crud-select (crud select)
  (:documentation "
Returns instances that match SELECT.  SELECT must select all
fields (\"*\").  See MAKE-SELECT."))

(defmethod crud-select (crud select)
  (if (detect-multiple-tables select)
      (crud-select-multiple crud select)
      (>> (with-crud (crud)
            (db-query (get-db-adapter crud) (apply-select select)))
          (when it
            (assert (equal "*" (get-select-property select :attr)))
            (rows-instances 
             crud (get-table-class 
                   crud (get-select-property select :table)) it)))))

(defun extract-multiple-tables (select)
  (let ((res)
        (table (get-select-property select :table))
        (join (get-select-property select :join)))
    (if (listp table)
        (dolist (ta table)
          (push ta res))
        (push table res))
    (if (listp join)
        (dolist (j join)

          (push
           (subseq j 0 (position #\Space j))
           #+nil (cl-ppcre:register-groups-bind (a) ("(.*?) " j) a)
           res))
        (push 
         (subseq join 0 (position #\Space join))
         #+nil (cl-ppcre:register-groups-bind (a) ("(.*?) " join) a)
              res))
    (nreverse res)))

(defmethod get-last-id ((crud crud))
  (get-last-id (get-db-adapter crud)))

(defgeneric crud-create (crud table values)
  (:documentation "
Adds a new row to the database of CRUD.

Example: 
 (CRUD-CREATE *crud* \"foo\" '(\"id\" 5 \"name\" \"John\"))"))

;; Create
(defmethod crud-create (crud table values)
  (>> (check-table-columns crud table values)
      (with-crud (crud)
        (db-execute (get-db-adapter crud) 
                    (crud-create/query crud table values))
        (when *return-instance*
          (let ((last (get-last-id crud)))
            (when last
              (crud-read crud table last)))))))


(defgeneric crud-create-from-instance (crud instance)
  (:documentation "
Adds a new row to the database of CRUD based on the slots of INSTANCE."))
         
(defmethod crud-create-from-instance (crud (instance db-response))
                                      
  (>> (crud-create/query crud 
                         (get-table-name instance)
                         (instance-string-list-bound instance))
      (with-crud (crud)
        (db-execute (get-db-adapter crud) it)
        (when *return-instance*
          (let ((last (get-last-id crud)))
            (when last
              (crud-read crud (get-table-name instance) last))))))) 

(defmethod crud-create/query (crud table values)
  (flet ((f (x)
           (database-format-value x)))    
    (multiple-value-bind (a b) (unzip values)
      (format nil "insert into ~A (~A) values (~A~{, ~A~});"
              table
              (format-list a)
              (f (first b)) 
              (mapcar #'f (rest b))))))  


;; Read

(defgeneric crud-read (crud table id)
  (:documentation "
Returns an instance corresponding to the row in TABLE with id ID."))

(defmethod crud-read (crud (table symbol) id)
  (crud-read crud (get-table-name table) id))

(defmethod crud-read (crud table id)
  (>> (check-table crud table)
      (crud-read/query crud table id)
      (with-crud (crud)
        (db-query (get-db-adapter crud) it))
      (when it
        (row-instance (get-table-class crud table) (car it)))))

(defgeneric crud-read-from-instance (crud instance)
  (:documentation "
Returns an fresh instance of INSTANCE from the database of CRUD."))

(defmethod crud-read-from-instance (crud (instance db-response))
  (crud-read crud (get-table-name instance) (get-id instance))) 

(defmethod crud-read/query (crud (table symbol) (id integer))
  (crud-read/query crud (get-table-name table) id))

(defmethod crud-read/query (crud (table string) (id integer))
  (format nil "select * from ~A where ~A = '~A';"
          table
          (get-id-field crud table) 
          id))


;; Update

(defgeneric crud-update (crud table id values)
  (:documentation "
Updates the row with id ID in TABLE with VALUES.

Example: 
 (CRUD-UPDATE *crud* \"foo\" 5 '(\"name\" \"John\"))"))

(defmethod crud-update (crud (table symbol) id values)
  (crud-update crud (get-table-name table) id values))

(defmethod crud-update (crud table id values)
  (>> (check-table-columns crud table values)
      (with-crud (crud)
        (db-execute (get-db-adapter crud)
                    (crud-update/query crud table id values)))
      (when *return-instance*
        (crud-read crud table id))))

(defgeneric crud-update-from-instance (crud instance)
  (:documentation "
Updates the row corresponding to INSTANCE with its slot values in the
database of CRUD."))

(defmethod crud-update-from-instance (crud (instance db-response))
  (with-crud (crud)
    (db-execute 
     (get-db-adapter crud)
     (crud-update/query crud 
                        (get-table-name instance)
                        (get-id instance)
                        (instance-string-list-bound instance)))
    (when *return-instance*
      (crud-read crud (get-table-name instance) 
                 (get-id instance)))))


(defmethod crud-update/query (crud table id values)
  (flet ((f (x)
           (database-format-value x)))    
    (format nil "update ~A set ~A = ~A~{, ~A = ~A~} where ~A = '~A';"
            table
            (first values)
            (f (second values))
            (loop :for (a b) :on (rest (rest values)) :by #'cddr
               :collect a :collect (f b))
            (get-id-field crud table) 
            id)))


;; Delete

(defgeneric crud-delete (crud table id)
  (:documentation "
Deletes the row with id ID in TABLE."))

(defmethod crud-delete (crud (table symbol) id)
  (crud-delete crud (get-table-name table) id))

(defmethod crud-delete (crud table id)
  (>> (check-table crud table)
      (with-crud (crud)
        (db-execute (get-db-adapter crud)
                    (crud-delete/query crud table id)))))

(defgeneric crud-delete-from-instance (crud instance)
  (:documentation "
Deletes the row corresponding to INSTANCE."))

(defmethod crud-delete-from-instance (crud (instance db-response))
  (with-crud (crud)
    (db-execute (get-db-adapter crud)
                (crud-delete/query crud (get-table-name instance) 
                                   (get-id instance)))))

(defmethod crud-delete/query (crud table id)
  (format nil "delete from ~A where ~A = '~A';"
          table
          (get-id-field crud table) 
          id))


;; Match


(defgeneric crud-match (crud instance)
  (:documentation "
Returns a set of instances that match the bound slots of INSTANCE."))

(defmethod crud-match (crud (instance db-response))
  (>> (crud-match/query crud instance)
      (with-crud (crud)
        (db-query (get-db-adapter crud) it))
      (when it
        (rows-instances crud (get-table-name instance) it))))
              
(defmethod crud-match/query (crud (instance db-response))
  (let* ((slots (get-slot-symbols instance))
         (slot-names (get-slot-strings instance))
         (constraints 
          (loop :for s :in slots
                :for n :in slot-names
                :for val = (if (slot-boundp instance s)
                               (slot-value instance s)
                               'unbound)
                :when (not (eq val 'unbound))
                :collect 
             (with-output-to-string (s)
               (write-string n s)
               (cond (val (write-string " = " s)
                          (princ (database-format-value val) s))                          
                     (t (princ " is NULL" s)))))))
    
    (format nil "select * from ~A where ~A~{ and ~A~};"
          (get-table-name instance)
          (first constraints)
          (rest constraints))))

;;;;;;;
